home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / Yerk 3.6.8 / Float source / fpi⁄o < prev    next >
Encoding:
Text File  |  1995-11-08  |  6.9 KB  |  205 lines  |  [TEXT/YERK]
  1. \ FPI/O -- floating-point I/O support for 68000 SANE engine.
  2. \    5/11/85     ssg Version 1.0
  3. \    9/26/85     cbd Modified for float heap, removed minor methods
  4. \    2/07/86     gdc Added words atof and f.r, changed eprint to eprint, printxyz
  5. \    8/16/86     cdn Eliminated finit & Stringer shorten
  6. \    5/26/91     rfl Eliminated Stringer class altogether.
  7. \ 10/26/91    rfl abs in front of /mod
  8. \ 12/17/92    rfl fixed a few problems that might occur due to not locking handles
  9. \ 01/26/93    rfl protect parse: to reject a possible float if 2 decimal points are mistakenly
  10. \                 adjacent. The case of " 1.234.56" is interpreted as an integer
  11. \ 12/03/93    rfl fixed problem with non FPU machines returning garbage exp when
  12. \                0 is passed to num2dec in float2dec:. Thanks to Harry Haddon.
  13. \                Removed 2 bytes scratch -use pad instead. Removed if true else false
  14. \ 12/05/93    rfl    Rewrote much of the formatting routines and added ability to
  15. \                get addr len of format on stack. More use of pack7 utilities.
  16. \ 05/19/94    rfl    fixed f.r for some ci's by setting digits instead of keeping constant=19
  17. \ 11/8/95    rfl    added f>asc and fe>asc
  18.  
  19. Decimal
  20.  
  21. \ Some useful constants
  22. 256 constant neg
  23.     0 constant pos
  24. 256 constant FixedDecimal
  25.     0 constant FloatDecimal
  26.     0 value topxyz                \ top of string being converted to float
  27.  
  28. 0 variable valid?            \ used for scan: but never used otherwise...mhore
  29.  
  30. \ reentrant code to get rid of leading zeros - not used here
  31. \ : endZ ( addr -- addr) dup c@ ascii 0 = IF 1+ endZ THEN ;
  32.  
  33. :CLASS        FPI/O    <Super Object
  34.  
  35.             \ SANE Record Decimal ( x:= (-1)^sgn * 10^exp * SigDig )
  36.             INT sgn        \ sign; 0=pos, 256=neg
  37.             INT exp        \ as if decimal point were to the right of SigDig
  38.             22 BYTES SigDig \ to fake string[20] ; 22 to make even
  39.  
  40.             \ SANE Record DecForm
  41.             INT style    \ Float=0; Fixed=256
  42.             INT digits    \ # of sig digits,if float; # dec. places,if fixed.
  43.  
  44.             string     floater         \ to hold formatted output string
  45.             string     expStr            \ to hold formatted exponent string
  46.             var         places            \ number of places to right of dec. pt.
  47.  
  48.             int index
  49.  
  50. ( -- )
  51.   :M    CLEAR:    addr: sgn 26 erase unlock: floater clear: floater clear: expstr ;M
  52.  
  53. ( -- )    \ Initialize strings etc.
  54.   :M    INIT:    new: floater new: expStr clear: self ;M
  55.  
  56. ( -- )
  57.   :M    EINIT:    clear: self FloatDecimal put: style  19 put: digits    ;M
  58.  
  59. ( -- )    \ Initialize for fixed conversion
  60.   :M    FINIT:    clear: self FixedDecimal put: style        ;M
  61.  
  62.   :M SET#DIGITS: put: digits    ;M
  63.  
  64. ( -- )    \ Puts a zero in decimal record
  65.   :M    ZERO:    clear: self     $ 0130 addr: sigDig w!        ;M
  66.  
  67. ( -- float )    \ ==== attempt to convert decimal to a float;
  68.   :M    DEC2FLOAT:    { \ flt     -- flt }
  69.         abs: sgn    \ Addr of decimal record
  70.         new: fltMem -> flt    flt 2+ +base    \ Absolute Destination address
  71.         $ 0009 \ FFEXT FOD2B + -- Opcode for decimal to binary; dest=extended
  72.         fp68k        flt            \ Call FP68K
  73.     ;M
  74.  
  75. ( float -- )            \ ==== convert float to decimal     ==== \
  76.   :M    FLOAT2DEC:    { flt -- }
  77.         abs: style     \ Absolute Addr of Decform record
  78.         flt 2+ +base            \ Absolute Addr of source
  79.         abs: sgn    \ Absolute Addr of Decimal record
  80.         $ 000b \ FFEXT FOB2D + -- Opcode for binary to decimal; source=extended
  81.         fp68k    flt fdrop        \ Call FP68K, dispose of float
  82. \         addr: sigDig 1+ c@ ascii 0 =
  83. \         IF clear: exp THEN
  84.     ;M
  85.  
  86. ( -- )    \ Set up float for in decimal record in scientific format,
  87. \                            left-justified in a field of width characters.
  88.   :M    num2dec: float2dec: self
  89.         abs: style (abs) pad +base call dec2str
  90.         pad count put: floater ;M
  91.  
  92.   :M    ROUND: ( f -- f') 1 swap 0 do 10 * LOOP >float fdup >r f* round r> f/ ;M
  93.  
  94. ( flt width -- addr len)
  95.   :M    GETEText: { width \ pos -- addr len } 
  96.             einit: self width 6 - put: digits
  97.             num2dec: self
  98.             start: floater ascii e charof: floater
  99.             IF drop size: floater substr: floater put: expStr
  100.                 width size: expStr - 3 max                \ bl or -, digit, decimal minimum
  101.                 size: floater size: expStr - min -> pos \ keep at least 2 numbers for decimal
  102.  
  103.                 pos moveto: floater                    \ round up NEED
  104.  
  105.                 size: floater substr: floater get: expStr replace: floater
  106.             ELSE addr: sigDig count drop c@
  107.                 dup ascii I = IF pad 1+ 1 put: floater
  108.                                 " Infinity" add: floater
  109.                                  width 10 - 0 DO bl +: floater LOOP
  110.                                 THEN
  111.                     ascii N = IF pad 1+ 1 put: floater width 14 >
  112.                                 IF " Not a number " add: floater
  113.                                      width 14 - 
  114.                                 ELSE " NaN " add: floater
  115.                                      width 5 -
  116.                                 THEN 
  117.                                 0 DO bl +: floater LOOP
  118.                                 THEN
  119.             THEN    lock: floater get: floater ;M
  120.  
  121.   :M EPRINT: geteText: self type ;M
  122.                                  \ Carry out f.r
  123.   :M GETFText: { width decimal \ dot -- addr len }
  124.     finit: self width 2- put: digits
  125.     decimal round: self num2dec: self
  126.     start: floater ascii . charof: floater
  127.     IF -> dot
  128.         decimal abs 1+ subStr: floater put: expStr
  129.         get: sgn not IF start: floater bl pad c! pad 1 insert: floater 1 ++> dot THEN
  130.         dot moveto: floater
  131.         size: floater substr: floater get: expStr replace: floater
  132.         size: floater width <
  133.         IF bl width size: floater -     fill: expStr
  134.             start: floater get: expStr insert: floater
  135.         THEN
  136.     ELSE addr: sigDig count drop c@
  137.         dup ascii I = IF get: sgn
  138.                         IF ascii - ELSE bl THEN pad c! pad 1 put: floater
  139.                          " Infinity" add: floater
  140.                          width 10 - 0 DO bl +: floater LOOP
  141.                         THEN
  142.             ascii N = IF get: sgn
  143.                             IF ascii - ELSE bl THEN pad c! pad 1 put: floater
  144.                             width 14 >
  145.                             IF " Not a number " add: floater width 14 -
  146.                             ELSE " NaN " add: floater width 5 -
  147.                             THEN 0 DO bl +: floater LOOP
  148.                         THEN
  149.             
  150.     THEN lock: floater get: floater ;M
  151.  
  152.   :M FPRINT: getFText: self type ;M
  153.  
  154.   :M SCAN: ( addr len --) str255 -base dup c@ 2+ padbl
  155.         buf255 +base 1+ clear: index abs: index (abs) valid? 3+ +base
  156.         call PStr2Dec ;M
  157.   :M CONV?: { addr len -- b } addr len scan: self get: index len = ;M
  158.  
  159. \ str255 format at addr
  160.   :M ATOF: ( addr -- f t | f )
  161.         count conv?: self     IF dec2float: self true ELSE false THEN ;M
  162.  
  163. ;Class
  164.  
  165. fpi/o floati/o            \ The default fpi/o object
  166. init: floati/o
  167.  
  168. ( width -- )
  169. ( flt -- )    \ Print a float in scientific format in a field of width chars.
  170. : e.r    ( flt width -- ) eprint: floati/o    ;
  171.  
  172. ( flt -- )    \ Print a float in scientific format.
  173. : e.    26 e.r ;
  174.  
  175. ( addr len -- fval T ) \    Successful        \ Converts a relative str255 string
  176. ( addr len -- F )        \    Unsuccessful    \ into a floating point number.
  177. : atof ( addr len -- f t | f )
  178.     str255 -base atof: floati/o ;
  179.  
  180. ( flt width decimal -- )    \ Print a float without exponents, in a field of
  181.                             \ width wide and of decimal places
  182. : f.r     ( flt width decimal -- ) fprint: floati/o ;
  183. : f>asc  ( flt width decimal -- addr len) getFtext: floati/o ;
  184. : fe>asc ( flt width -- addr len) getEText: floati/o ;
  185.  
  186. \ testing
  187. \ int index
  188. \ 0 variable valid?
  189. \ : scan str255 -base dup c@ 2+ padbl
  190. \    buf255 +base 1+ clear: index abs: index abs: floati/o valid? 3+ +base call PStr2Dec ;
  191. \ : conv { addr len -- f t | f } addr len scan get: index len = ;
  192.  
  193. \ : sgn floati/o get: int ;
  194. \ : exp floati/o 2+ get: int ;
  195. \ : sigdig floati/o 4+ count type ;
  196. \ : style floati/o 26 + get: int ;
  197. \ : digits floati/o 28 + get: int ;
  198. \ floati/o 30 + @ string floater floater !
  199. \ floati/o 38 + @ string expStr expStr !
  200. \ : places floati/o 46 + get: var ;
  201.  
  202.  
  203.  
  204.  
  205.